﻿Option Explicit On

Public Class FractalEncrypt

    Public Const CrLower As Double = 0.1
    Public Const CrUpper As Double = Math.PI / (2 * Math.E)
    Public Const CiLower As Double = 0.1
    Public Const CiUpper As Double = Math.PI / (2 * Math.E)

    Public ReadOnly Cr As Double, Ci As Double, Sr As Double, Si As Double
    Public ReadOnly BaseSeq As Integer

    Public Sub New(ByVal KeyR As Double, ByVal KeyI As Double, ByVal SaltR As Double, ByVal SaltI As Double, ByVal SeqStart As Integer)
        Cr = ((KeyR - CrLower) Mod (CrUpper - CrLower)) + CrLower
        Ci = ((KeyI - CiLower) Mod (CiUpper - CiLower)) + CiLower

        Sr = ((SaltR - CrLower) Mod (CrUpper - CrLower)) + CrLower
        Si = ((SaltI - CiLower) Mod (CiUpper - CiLower)) + CiLower

        BaseSeq = SeqStart
    End Sub

    Public Function Encrypt(ByVal Text As String, ByVal Seq As Integer) As String
        'Encrypt the string passed, adding on the sequence as a header.
        Debug.Print("Encrypt<" & Seq & ">" & Len(Text) & ":" & Text)
        Dim CurSeq = BaseSeq + Seq
        'make the sequence prefix
        Dim enc As String = Format(Seq, "000000000") & ":"

        Dim EncryptedOffset As Integer = 0
        Do While EncryptedOffset < Len(Text)
            'encrypt each 4 characters separately
            enc = enc & Encrypt4(Text, EncryptedOffset, CurSeq)
            EncryptedOffset = EncryptedOffset + 4
        Loop

        Return enc
    End Function

    Public Function Decrypt(ByVal CrypText As String) As String
        'Decrypt the string passed, extracting the Sequence header first.

        'Extract the sequence
        Dim Seq As Integer = CInt(Left(CrypText, 9))
        Dim CurSeq = BaseSeq + Seq

        'Extract the excrypted message payload
        CrypText = Mid(CrypText, 11)
        Debug.Print("Decrypt<" & Seq & ">" & Len(CrypText) & ":" & CrypText)

        'Now decrypt it 4 characters at a time
        Dim txt As String = ""
        Dim EncryptedOffset As Integer = 0
        Do While EncryptedOffset < Len(CrypText)
            'encrypt each 4 characters separately
            txt = txt & Encrypt4(CrypText, EncryptedOffset, CurSeq)
            EncryptedOffset = EncryptedOffset + 4
        Loop

        Return txt
    End Function

    Public Function Encrypt4(ByVal text As String, ByVal StrOffs As Integer, ByVal CurSeq As Integer) As String
        'Encrypt/Decrypt 4 characters of the string.
        ' (note: encrypt and decrypt are the same operation because XOR is its own compliment)
        Dim str As String = Mid(text, StrOffs + 1, 4)
        Dim enc As String

        'generate the seeds from the current message sequence and the current string offset
        '1.   define complex Seq as (CurSeq, StrOffs)
        Dim SeedR As Double = (Sr * CurSeq) - (Si * StrOffs)
        Dim SeedI As Double = (Sr * StrOffs) + (Si * CurSeq)
        '2.   remap the result back into the valid range
        SeedR = SeedR Mod (CrUpper - CrLower)
        SeedI = SeedI Mod (CiUpper - CiLower)

        'generate the local keys from the master keys
        Dim Zr As Double = SeedR, Zi As Double = SeedI
        Dim r As Double, i As Double, zx As Integer = 0, zy As Integer = 0
        '1.  apply the julia formula 16 times to hash it up good.
        For j As Integer = 1 To 16
            'Z(n+1) = Z(n)^2 - C:
            r = Zr * Zr - Zi * Zi - Cr
            i = 2 * Zr * Zi - Ci
            If Double.IsInfinity(r) Or Double.IsNaN(r) Then r = (zx \ zy) 'force an error
            If Double.IsInfinity(i) Or Double.IsNaN(i) Then i = (zx \ zy) 'force an error
            'put back int Z:
            Zr = r : Zi = i
        Next
        '2.  remap the back into our results window
        Zr = ((Zr - CrLower) Mod (CrUpper - CrLower)) + CrLower
        Zi = ((Zi - CiLower) Mod (CiUpper - CiLower)) + CiLower

        'Form the local keys into the Mask Keys variables (M).'
        Dim Mr As Integer, Mi As Integer
        '1.  scale them both into the range of about 2^30.
        Mr = CInt((1024 * 1024 * 1024) * (Zr - CrLower) / (CrUpper - CrLower))
        Mi = CInt((1024 * 1024 * 1024) * (Zi - CiLower) / (CiUpper - CiLower))
        '2.  only use the lower 16 bits that are left:
        Mr = Mr And 65535 : Mi = Mi And 65535

        'encode the current 4 characters as a 2 * 2-byte integer
        Dim R2 As Integer, I2 As Integer
        If StrOffs + 1 <= Len(text) Then R2 = Asc(Mid(text, StrOffs + 1, 1))
        If StrOffs + 2 <= Len(text) Then R2 = R2 + 256 * Asc(Mid(text, StrOffs + 2, 1))
        If StrOffs + 3 <= Len(text) Then I2 = Asc(Mid(text, StrOffs + 3, 1))
        If StrOffs + 4 <= Len(text) Then I2 = I2 + 256 * Asc(Mid(text, StrOffs + 4, 1))

        'Encrypt (or Decrypt) the data by masking it with the local Keys
        R2 = R2 Xor Mr
        I2 = I2 Xor Mi

        'recode them as ascii strings again:
        enc = Chr(R2 And 255) & Chr(R2 \ 256) & Chr(I2 And 255) & Chr(I2 \ 256)

        Debug.Print(" (" & CurSeq & "," & Format(StrOffs, "000") & "): " _
                & Zr & ":" & Mr & ", " & Zi & ":" & Mi _
                & " " & (R2 And 255) & "/" & (R2 \ 256) & "/" & (I2 And 255) & "/" & (I2 \ 256))
        Return enc
    End Function
End Class

